home *** CD-ROM | disk | FTP | other *** search
/ Macwelt 1 / Macwelt DVD 1.toast / Web-Publishing / HTML-Editoren / Alpha ƒ / Tcl / SystemCode / CorePackages / cache.tcl < prev    next >
Encoding:
Text File  |  2000-12-11  |  10.1 KB  |  362 lines
  1. ## -*-Tcl-*-
  2.  # ###################################################################
  3.  #  AlphaTcl - core Tcl engine
  4.  # 
  5.  #  FILE: "cache.tcl"
  6.  #                                    created: 17/7/97 {3:21:07 pm} 
  7.  #                                last update: 12/11/2000 {12:18:51 PM} 
  8.  #  Author: Vince Darley
  9.  #  E-mail: <vince@santafe.edu>
  10.  #    mail: 317 Paseo de Peralta
  11.  #          Santa Fe, NM 87501, USA
  12.  #     www: <http://www.santafe.edu/~vince/>
  13.  #  
  14.  # Copyright (c) 1997-2000  Vince Darley, all rights reserved
  15.  # 
  16.  # Usage:
  17.  # 
  18.  #  cache::create 'name'
  19.  #  cache::add 'name' variable var1 var2 ...
  20.  #  cache::add 'name' eval "beep" "menu Blah {}" ...
  21.  # 
  22.  # then:
  23.  # 
  24.  #  if {[cache::exists 'name']} {
  25.  #     cache::readContents 'name'
  26.  #     puts "var1 = $var1, var2 = $var2"
  27.  #     puts "Also I beeped and created a menu 'Blah'"
  28.  #  }
  29.  # 
  30.  # Alternatively, and useful when, say, you want to store lots of little 
  31.  # pieces of information, each with a different name (not really
  32.  # associated with a particular variable, though), you can do this:
  33.  # 
  34.  #  cache::snippetWrite 'item1' value1
  35.  #  cache::snippetWrite 'item2' value2
  36.  #  
  37.  # then:
  38.  # 
  39.  #  puts [cache::snippetRead item1]
  40.  #  puts [cache::snippetRead item2]
  41.  #  
  42.  # This is useful if you wish to build up a large menu from lots of
  43.  # little pieces, each of which is cached separately, because they
  44.  # may all change individually.
  45.  # 
  46.  # There are also procs to delete a cache, remove a snippet, or find
  47.  # out which variables are stored in a cache.
  48.  #  
  49.  # ###################################################################
  50.  ##
  51.  
  52. namespace eval cache {}
  53. # so if we make incompatible changes we can automatically delete
  54. # or re-interpret incompatible caches.
  55. set cache::version 1.1
  56.  
  57. ## 
  58.  # -------------------------------------------------------------------------
  59.  # 
  60.  # "cache::exists" --
  61.  # 
  62.  #  Is there a cache with the given name
  63.  # -------------------------------------------------------------------------
  64.  ##
  65. proc cache::exists {name} {
  66.     return [file exists [cache::name $name]]
  67. }
  68.  
  69. proc cache::compareDates {name1 op name2} {
  70.     file::compareDates [cache::name $name1] $op [cache::name $name2]
  71. }
  72.  
  73. ## 
  74.  # -------------------------------------------------------------------------
  75.  # 
  76.  # "cache::readContents" --
  77.  # 
  78.  #  Read all the information from the given cache, into the _current_
  79.  #  execution level.  If you're in a proc and you want to read the
  80.  #  cache (or some of it) into global variables, you must precede
  81.  #  this call with a 'global' statement.
  82.  #  
  83.  #  If the cache doesn't exist this proc will give an error.
  84.  #  Use 'cache::exists' first to check.
  85.  # -------------------------------------------------------------------------
  86.  ##
  87. if {[info tclversion] < 8.0} {
  88.     proc cache::readContents {name} {
  89.     uplevel 1 {set cache::eval 1}
  90.     uplevel 1 [list source [cache::name $name]]
  91.     uplevel 1 {unset cache::eval}
  92.     }
  93. } else {
  94.     proc cache::readContents {name} {
  95.     uplevel 1 {namespace eval cache {}}
  96.     uplevel 1 {set cache::eval 1}
  97.     uplevel 1 [list source [cache::name $name]]
  98.     uplevel 1 {unset cache::eval}
  99.     }
  100. }
  101.  
  102. ## 
  103.  # -------------------------------------------------------------------------
  104.  # 
  105.  # "cache::readItem" --
  106.  # 
  107.  #  Read the value of a single cached item.  Not very efficient.  If you
  108.  #  want to do this a lot, you should think about storing 'snippets'
  109.  #  using the cache::snippetRead/Write procedures.
  110.  # -------------------------------------------------------------------------
  111.  ##
  112. proc cache::readItem {name item} {
  113.     set cache::eval 0
  114.     source [cache::name $name]
  115.     return [set $item]
  116. }
  117.  
  118. ## 
  119.  # -------------------------------------------------------------------------
  120.  # 
  121.  # "cache::variables" --
  122.  # 
  123.  #  Returns a list of the variables stored in the given cache
  124.  # -------------------------------------------------------------------------
  125.  ##
  126. proc cache::variables {name} {
  127.     set cache::eval 0
  128.     source [cache::name $name]
  129.     return [lremove [info vars *] cache::eval name]
  130. }
  131.  
  132. ## 
  133.  # -------------------------------------------------------------------------
  134.  # 
  135.  # "cache::create" --
  136.  # 
  137.  #  Write the given cache name with the given value.  If any other arguments
  138.  #  are given, they are the names of other variables/arrays which should
  139.  #  also be stored.
  140.  # -------------------------------------------------------------------------
  141.  ##
  142. proc cache::create {name args} {
  143.     close [cache::fopen $name create]
  144.     if {[llength $args]} {
  145.     uplevel 1 "cache::add [list $name] $args"
  146.     }
  147. }
  148.  
  149. proc cache::delete {args} {
  150.     foreach name $args {
  151.     if {[cache::exists $name]} {
  152.         catch {file delete [cache::name $name]}
  153.     }
  154.     }
  155. }
  156.  
  157. proc cache::deletePat {name} {
  158.     set path [cache::name $name]
  159.     foreach f [glob -nocomplain -dir [file dirname $path] -- [file tail $path]] {
  160.     catch {file delete $f}
  161.     }
  162. }
  163.  
  164. if {[info tclversion] < 8.0} {
  165.     proc cache::name {name} {
  166.     global PREFS
  167.     regsub -all "::" $name ":" name
  168.     return "${PREFS}:Cache:${name}"
  169.     }
  170. } else {
  171.     # fix things up for cross-platform tcl 8
  172.     proc cache::name {name} {
  173.     global PREFS
  174.     if {[regexp {(.*)::[^:]+} $name "" ns]} {
  175.         # currently only allows one level of nesting
  176.         uplevel 1 "namespace eval $ns {}"
  177.         regsub -all "::" $name ":" name
  178.         set name [eval file join [split $name :]]
  179.     }
  180.     return [file join ${PREFS} Cache ${name}]
  181.     }
  182. }
  183.  
  184. ## 
  185.  # -------------------------------------------------------------------------
  186.  # 
  187.  # "cache::add" --
  188.  # 
  189.  #  Write additional information into a pre-existing cache.  The other
  190.  #  arguments are just variable names to store, if type is 'variable'.
  191.  #  Otherwise they are strings to be evaluated, if type is 'eval'.
  192.  # -------------------------------------------------------------------------
  193.  ##
  194. proc cache::add {name type args} {
  195.     set fcache [cache::fopen $name append]
  196.     switch -- $type {
  197.     "variable" {
  198.         foreach a $args {
  199.         upvar $a var
  200.         if {[array exists var]} {
  201.             foreach n [array names var] {
  202.             puts $fcache [list set ${a}(${n}) [set var(${n})]]
  203.             }
  204.         } else {
  205.             if {[info exists var]} {
  206.             puts $fcache [list set $a [set var]]
  207.             }
  208.         }
  209.         }
  210.     }
  211.     "list" {
  212.         foreach a $args {
  213.         upvar $a var
  214.         if {[info exists var]} {
  215.             puts $fcache "lappend [list $a] [set var]"
  216.         }
  217.         }
  218.     }
  219.     "eval" {
  220.         foreach a $args {
  221.         puts $fcache [list if \$\{cache::eval\} [list eval $a]]
  222.         }
  223.     }
  224.     default {
  225.         close $fcache
  226.         return -code error "Unknown type '$type' to cache::add"
  227.     }
  228.     }
  229.     close $fcache
  230. }
  231.  
  232. ## 
  233.  # -------------------------------------------------------------------------
  234.  # 
  235.  # "cache::fopen" --
  236.  # 
  237.  #  You shouldn't really call this procedure.  Call the others.
  238.  # -------------------------------------------------------------------------
  239.  ##
  240. proc cache::fopen {name {action "create"}} {
  241.     file::ensureDirExists [file dirname [set c [cache::name $name]]]
  242.     switch -- $action {
  243.     "create" {
  244.         set fcache [alphaOpen $c w]
  245.         puts $fcache "# -*-Tcl-*- (nowrap)"
  246.         global cache::version
  247.         puts $fcache "# Cache v${cache::version} created on [mtime [now]]"
  248.     }
  249.     "append" {
  250.         if {![file exists $c]} {close [cache::fopen $name create]}
  251.         set fcache [alphaOpen $c a]
  252.     }
  253.     "read" {
  254.         if {![file exists $c]} {close [cache::fopen $name create]}
  255.         set fcache [alphaOpen $c r]
  256.     }
  257.     default {
  258.         error "No such cache action '$action'"
  259.     }
  260.     }
  261.     return $fcache
  262. }
  263.  
  264. ## 
  265.  # -------------------------------------------------------------------------
  266.  # 
  267.  # "cache::snippetWrite" --
  268.  # 
  269.  #  Store a small snippet $value, using '$name' as an identifier with
  270.  #  which to retrieve it later.
  271.  #  
  272.  #  Snippets are stored efficiently in a single file, and retrieved
  273.  #  by examining the contents of that file directly.  This is
  274.  #  quicker than setting/unsetting lots of vars if you wish to
  275.  #  ask for a variety of snippets in different places in your
  276.  #  code.
  277.  #  
  278.  #  I think this proc works ok with all the weird characters, but
  279.  #  I may have missed something.
  280.  # -------------------------------------------------------------------------
  281.  ##
  282. proc cache::snippetWrite {name value {file "_snippet_"}} {
  283.     cache::readFile $file contents
  284.     set reg [quote::Regfind [list set _snippet_cache(${name})]]
  285.     if {[regsub -- "$reg (\[^\n\]*)\n" $contents "[list set _snippet_cache(${name}) [quote::Regsub $value]]\n" contents]} {
  286.     cache::writeFile $file contents
  287.     } else {
  288.     set "_snippet_cache($name)" $value
  289.     cache::add $file "variable" _snippet_cache($name)
  290.     }
  291. }
  292.  
  293. ## 
  294.  # -------------------------------------------------------------------------
  295.  # 
  296.  # "cache::snippetRead" --
  297.  # 
  298.  #  Retrieve a previously stored snippet.
  299.  # -------------------------------------------------------------------------
  300.  ##
  301. proc cache::snippetRead {name {file "_snippet_"}} {
  302.     cache::readFile $file contents
  303.     set reg [quote::Regfind [list set _snippet_cache(${name})]]
  304.     if {[regexp -- "$reg (\[^\n\]*)\n" $contents "" val]} {
  305.     eval return $val
  306.     } else {
  307.     return ""
  308.     }
  309. }
  310.  
  311. proc cache::snippetRemove {name {file "_snippet_"}} {
  312.     cache::readFile $file contents
  313.     set reg [quote::Regfind [list set _snippet_cache(${name})]]
  314.     if {[regsub -- "$reg (\[^\n\]*)\n" $contents "" contents]} {
  315.     cache::writeFile $file contents
  316.     }
  317. }
  318.  
  319. proc cache::snippetExists {name  {file "_snippet_"}} {
  320.     cache::readFile $file contents
  321.     set reg [quote::Regfind [list set _snippet_cache(${name})]]
  322.     return [regexp -- "$reg (\[^\n\]*)\n" $contents "" val]
  323. }
  324.  
  325. ## 
  326.  # -------------------------------------------------------------------------
  327.  # 
  328.  # "cache::readFile" --
  329.  # 
  330.  #  Read the entire contents of a cache into the given variable
  331.  # -------------------------------------------------------------------------
  332.  ##
  333. proc cache::readFile {name contents} {
  334.     set f [cache::name $name]
  335.     upvar $contents c
  336.     if {[file exists $f] && [file readable $f]} {
  337.     set fileid [alphaOpen $f "r"]
  338.     set c [read $fileid]
  339.     close $fileid
  340.     } else {
  341.     set c ""
  342.     }
  343. }
  344.  
  345. ## 
  346.  # -------------------------------------------------------------------------
  347.  # 
  348.  # "cache::writeFile" --
  349.  # 
  350.  #  Overwrite a cache with the value of the given variable 
  351.  # -------------------------------------------------------------------------
  352.  ##
  353. proc cache::writeFile {name contents} {
  354.     upvar $contents c
  355.     set fileid [alphaOpen [cache::name $name] "w"]
  356.     puts -nonewline $fileid $c
  357.     close $fileid
  358. }
  359.  
  360.  
  361.  
  362.